home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Source Code / Peter Lewis / Morpion 1.0.0 / source / PNL Libraries / MyStrings.unit < prev    next >
Encoding:
Text File  |  1993-09-02  |  5.2 KB  |  224 lines  |  [TEXT/PJMM]
  1. unit MyStrings;
  2.  
  3. interface
  4.  
  5.     procedure LeftP (var s: str255; len: integer);
  6.     function Left (var s: str255; len: integer): str255;
  7.     procedure LeftAssignP (var s: str255; len: integer; var rhs: str255);
  8.     function LeftAssign (var s: str255; len: integer; var rhs: str255): str255;
  9.     procedure RightP (var s: str255; len: integer);
  10.     function Right (var s: str255; len: integer): str255;
  11.     procedure RightAssignP (var s: str255; len: integer; var rhs: str255);
  12.     function RightAssign (var s: str255; len: integer; var rhs: str255): str255;
  13.     procedure MidP (var s: str255; p, len: integer);
  14.     function Mid (var s: str255; p, len: integer): str255;
  15.     procedure MidAssignP (var s: str255; p, len: integer; var rhs: str255);
  16.     function MidAssign (var s: str255; p, len: integer; var rhs: str255): str255;
  17.     procedure HandleToStringP (h: univ handle; var s: str255);
  18.     function HandleToString (h: univ handle): str255;
  19.     procedure StringToHandle (var s: str255; h: univ handle);
  20.     function Trim (s: string): string;
  21.     procedure SplitBy (s: str255; ch: char; var left, right: str255);
  22.     function UpCaseChar (ch: char): char;
  23.     function UpCase (ch: char): char;
  24.     inline
  25.         $301F, $0C00, $0061, $6500, $000E, $0C00, $007B, $6400, $0006, $0400, $0020, $3E80;
  26.     procedure UpCaseString (var s: string);
  27.     function UpCaseStr (s: string): string;
  28. {    procedure SPrintS5V (var dst: str255;var  src,s1, s2, s3, s4, s5: str255);}
  29.     procedure SPrintS5 (var dst: str255; src, s1, s2, s3, s4, s5: str255);
  30.     procedure SPrintS3 (var dst: str255; src, s1, s2, s3: str255);
  31.  
  32. implementation
  33.  
  34.     uses
  35.         MyTypes;
  36.  
  37.     procedure LeftP (var s: str255; len: integer);
  38.     begin
  39.         s := copy(s, 1, len);
  40.     end;
  41.  
  42.     function Left (var s: str255; len: integer): str255;
  43.     begin
  44.         Left := copy(s, 1, len);
  45.     end;
  46.  
  47.     procedure LeftAssignP (var s: str255; len: integer; var rhs: str255);
  48.     begin
  49.         s := concat(rhs, copy(s, len + 1, 255));
  50.     end;
  51.  
  52.     function LeftAssign (var s: str255; len: integer; var rhs: str255): str255;
  53.     begin
  54.         LeftAssign := concat(rhs, copy(s, len + 1, 255));
  55.     end;
  56.  
  57.     procedure RightP (var s: str255; len: integer);
  58.         var
  59.             p: integer;
  60.     begin
  61.         p := Length(s) - len;
  62.         if p < 1 then
  63.             p := 1;
  64.         s := copy(s, p, 255);
  65.     end;
  66.  
  67.     function Right (var s: str255; len: integer): str255;
  68.         var
  69.             p: integer;
  70.     begin
  71.         p := Length(s) - len;
  72.         if p < 1 then
  73.             p := 1;
  74.         Right := copy(s, p, 255);
  75.     end;
  76.  
  77.     procedure RightAssignP (var s: str255; len: integer; var rhs: str255);
  78.     begin
  79.         s := concat(copy(s, 1, Length(s) - len), rhs);
  80.     end;
  81.  
  82.     function RightAssign (var s: str255; len: integer; var rhs: str255): str255;
  83.     begin
  84.         RightAssign := concat(copy(s, 1, Length(s) - len), rhs);
  85.     end;
  86.  
  87.     procedure MidP (var s: str255; p, len: integer);
  88.     begin
  89.         s := copy(s, p, len);
  90.     end;
  91.  
  92.     function Mid (var s: str255; p, len: integer): str255;
  93.     begin
  94.         Mid := copy(s, p, len);
  95.     end;
  96.  
  97.     procedure MidAssignP (var s: str255; p, len: integer; var rhs: str255);
  98.     begin
  99.         s := concat(copy(s, 1, p - 1), rhs, copy(s, p + len + 1, 255));
  100.     end;
  101.  
  102.     function MidAssign (var s: str255; p, len: integer; var rhs: str255): str255;
  103.     begin
  104.         MidAssign := concat(copy(s, 1, p - 1), rhs, copy(s, p + len + 1, 255));
  105.     end;
  106.  
  107. {$PUSH}
  108. {$R-}
  109.     procedure HandleToStringP (h: univ handle; var s: str255);
  110.         var
  111.             len: longInt;
  112.     begin
  113.         len := GetHandleSize(h);
  114.         if len > 255 then
  115.             len := 255;
  116.         s[0] := chr(len);
  117.         BlockMove(h^, @s[1], len);
  118.     end;
  119. {$POP}
  120.  
  121.     function HandleToString (h: univ handle): str255;
  122.         var
  123.             s: str255;
  124.     begin
  125.         HandleToStringP(h, s);
  126.         HandleToString := s;
  127.     end;
  128.  
  129. {$PUSH}
  130. {$R-}
  131.     procedure StringToHandle (var s: str255; h: univ handle);
  132.     begin
  133.         SetHandleSize(h, length(s));
  134.         BlockMove(@s[1], h^, length(s));
  135.     end;
  136. {$POP}
  137.  
  138.     function Trim (s: string): string;
  139.     begin
  140.         while (length(s) > 0) and (s[1] in [spc, tab]) do
  141.             Delete(s, 1, 1);
  142.         while (length(s) > 0) and (s[length(s)] in [spc, tab]) do
  143.             Delete(s, length(s), 1);
  144.         Trim := s;
  145.     end;
  146.  
  147.     procedure UpCaseString (var s: string);
  148.         var
  149.             i: integer;
  150.     begin
  151.         for i := 1 to length(s) do begin
  152.             s[i] := UpCase(s[i]);
  153.         end;
  154.     end;
  155.  
  156.     function UpCaseStr (s: string): string;
  157.         var
  158.             i: integer;
  159.     begin
  160.         for i := 1 to length(s) do
  161.             s[i] := UpCase(s[i]);
  162.         UpCaseStr := s;
  163.     end;
  164.  
  165.     function UpCaseChar (ch: char): char;
  166.     begin
  167.         if ('a' <= ch) & (ch <= 'z') then
  168.             UpCaseChar := chr(ord(ch) - $20)
  169.         else
  170.             UpCaseChar := ch;
  171.     end;
  172.  
  173.     procedure DoSub (var dst: str255; n: integer; var s: str255);
  174.         var
  175.             p: integer;
  176.     begin
  177.         p := Pos(concat('^', chr(n + 48)), dst);
  178.         if p > 0 then begin
  179.             Delete(dst, p, 2);
  180.             Insert(s, dst, p);
  181.         end;
  182.     end;
  183.  
  184. {$Z+}
  185.     procedure SPrintS5V (var dst: str255; var src, s1, s2, s3, s4, s5: str255);
  186.     begin
  187.         dst := src;
  188.         DoSub(dst, 5, s5);
  189.         DoSub(dst, 4, s4);
  190.         DoSub(dst, 3, s3);
  191.         DoSub(dst, 2, s2);
  192.         DoSub(dst, 1, s1);
  193.     end;
  194. {$Z-}
  195.  
  196.     procedure SPrintS5 (var dst: str255; src, s1, s2, s3, s4, s5: str255);
  197.     begin
  198.         SPrintS5V(dst, src, s1, s2, s3, s4, s5);
  199.     end;
  200.  
  201.     procedure SPrintS3 (var dst: str255; src, s1, s2, s3: str255);
  202.     begin
  203.         dst := src;
  204.         DoSub(dst, 3, s3);
  205.         DoSub(dst, 2, s2);
  206.         DoSub(dst, 1, s1);
  207.     end;
  208.  
  209.     procedure SplitBy (s: str255; ch: char; var left, right: str255);
  210.         var
  211.             p: integer;
  212.     begin
  213.         p := Pos(ch, s);
  214.         if p <= 0 then begin
  215.             left := s;
  216.             right := '';
  217.         end
  218.         else begin
  219.             left := copy(s, 1, p - 1);
  220.             right := copy(s, p + 1, 255);
  221.         end;
  222.     end;
  223.  
  224. end.